home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / Clone / clone.f < prev    next >
Encoding:
FORTH Source  |  1992-06-04  |  33.1 KB  |  1,358 lines
  1. \ ------------------  CLONECFA ... the big one! -------------------- /
  2. \
  3. \   When an unresolved reference is target compiled, two behaviors are
  4. \ possible:
  5. \
  6. \ 1. Leave 3 words (48 bits) so that  a LONG ABS may be used.  This
  7. \    usually will only be filled with a relative BSR and a NOOP, however.
  8. \    A program will have to significantly exceed 128k, actually, before
  9. \    a LONG ABSOLUTE JSR is required.  Better to try...
  10. \
  11. \ 2. Only leave 32-bit cells on the HIGH probability that all the code
  12. \    will fit under 128k (Target Compiled!).
  13. \
  14. \   The following variable 'IfLeaveLong' allows the selection of either.
  15. \ If set TRUE, it will leave 48-bit holes.  Do NOT change this while
  16. \ Target Compiling is in progress!  Leaving this variable FALSE is heartily
  17. \ reccomended; if your code is huge, wait till the error message, then set it
  18. \ TRUE and start over.
  19.  
  20. \ 00001 18-jan-91 mdh  fixed problem with ALITERALs  ( added swap )
  21. \ 00002 PLB 1/29/91 Remove duplicate TARGETABS +STACK in ResolveAll
  22. \ 00003 PLB 2/5/91 Add IF.FORGOTTEN INITCLONE
  23. \ 00004 PLB/MDH 2/6/91 Add calls to SizeDiff? in CloneUnresolved
  24. \ 00005 mdh 4/24/91 new defer
  25.  
  26. only forth definitions
  27.  
  28. decimal  ANew TASK-Clone.f
  29.  
  30. variable IfLeaveLong   \ if non-zero, leave 3 words (see above text)...
  31. variable InitialImageSize  ( starting size to avoid expansion )
  32. variable IfLongBranch
  33.  
  34. also TGT definitions
  35.  
  36.  
  37. \ flags and general variables...
  38.  
  39. variable PktBase       \ address of the 'attribute' packet for this CFA...
  40. variable TargetBase    \ the address of this word in the target...
  41. variable HiBranch      \ an RTS without a branch around means done...
  42. variable CurrentDiff   \ current difference in pfa size
  43. variable ThisOp
  44. variable SPECIAL_ID
  45. variable TargetDataStart
  46.  
  47. 1 array testarray
  48.  
  49. \ stacks ...
  50.  
  51.   0 DynamicStack UnResolved  \ to 'remember' calls to the non-existant ones...
  52.   0 DynamicStack TargetABS   \ for tracking required Long Relocations...
  53. 128 DynamicStack DiffSizes   \ addrs of size diffs and the diffs...
  54.   8 DynamicStack BranchAdrs  \ local stack pointing to the Branch opcodes...
  55.   0 DynamicStack OpenCells   \ will be resolved to an address...
  56. 128 DynamicStack ?DOIndexes
  57.   8 DynamicStack ValueRefs
  58.   8 DynamicStack CFATables
  59.   8 DynamicStack TGTCFATables
  60.   8 DynamicStack :ClassCFAS
  61.   8 DynamicStack DictPCRels
  62.   8 DynamicStack ImagePCRels
  63.   8 DynamicStack FromCFAs
  64.  
  65. also forth definitions
  66.  
  67.  
  68. : InitClone
  69.   UnResolvedVAR FreeStack
  70.   TargetABSVAR  FreeStack
  71.   DiffSizesVAR  FreeStack
  72.   BranchAdrsVAR FreeStack
  73.   OpenCellsVAR  FreeStack
  74.   ?DOIndexesVAR FreeStack
  75.   ValueRefsVAR  FreeStack
  76.   CFATables     FreeStack
  77.   TGTCFATables  FreeStack
  78.   :ClassCFAS    FreeStack
  79.   DictPCRels    FreeStack
  80.   ImagePCRels   FreeStack
  81.   FromCFAs      FreeStack
  82.   InitClone
  83. ;
  84.  
  85. if.forgotten initclone \ 00003
  86.  
  87. previous definitions
  88.  
  89. .need K
  90. : K 1024 * ;
  91. .then
  92.  
  93.  
  94.  
  95. USE_NEW_COLON on
  96.  
  97. \ 10 constant OVERLAY_CALL_SIZE
  98.    4 constant OVERLAY_CALL_SIZE
  99.  
  100. : CALCCALL  ( calledOpAdr callingOpAdr -- opcode data #bytes , if #bytes<8)
  101.             (                     ELSE    opcode w@aN-2 .. w@a0 N*2 )
  102.   \
  103.   CloneOverlay @    InMaster @ 0=  AND
  104.   IF
  105. \ x ) dbgon >newline ." CALCCALL passed an overlay function: " .s >newline dbgoff
  106.      \ need new 'call' mechanism...
  107. [ 0 .if ]
  108.      \
  109.      \ move.l  #CalledAdr,a0
  110.      \ jsr     0(a5,a0.l)     a5 set by StartOverlay (in startjforth.asm)
  111.      \
  112.      >r        >r
  113.      $ 8800    $ 4eb5
  114.      r@        r> 16 -shift
  115.      $ 207c
  116.      OVERLAY_CALL_SIZE        rdrop
  117. [ .else ]
  118.      \
  119.      \ bsr  calledaddr
  120.      \
  121.      2dup 2+ -  [ decimal ]  dup -32769 >  over 32768 < and
  122.      IF
  123.         -rot 2drop   $ 6100  swap  4
  124.      ELSE
  125.         cr ." Overlay too large.  CLONE Aborted." quit
  126.      THEN
  127. [ .then ]
  128.   ELSE
  129.      \ is it within relative-distance range?
  130.      \
  131.      InMaster @
  132.      IF
  133.         0 0   \ can't allow if in master
  134.      ELSE
  135.         2dup 2+ -  [ decimal ]  dup -32769 >  over 32768 < and
  136.      THEN
  137.      ( -- cldop clngop rel-displacement flag )
  138.      IF
  139.         -rot 2drop   $ 6100  swap  4
  140.      ELSE
  141.         drop
  142.         over  [ 32 k ] literal <
  143.         IF
  144.            \
  145.            \ Origin relative...
  146.            \
  147.            drop $ 4eac swap 4
  148.         ELSE
  149.            \
  150.            \ if 32k - 96k, use +64k relative...
  151.            \
  152.            over  [ 96 k ] literal <
  153.            IF
  154.               drop  [ 64 k ] literal -  $ 4eab swap   4
  155.            ELSE
  156.               \
  157.               \ Push CallingOpAdr+2 on TargetABS stack for relocation.
  158.               2+ TargetABS +stack  $ 4eb9 swap 6
  159.            THEN
  160.         THEN
  161.      THEN
  162.   THEN 
  163. ;
  164.  
  165. USE_NEW_COLON off
  166.  
  167.  
  168.  
  169. \ ----------- AllotData ------------------------------------------
  170. \
  171.  
  172. : AllotDATA  ( areastart -- )
  173.   NextLFA drop
  174.   Mindiff @  4 max            \ TargetAllot
  175.   cell /mod swap IF 1+ THEN   ( -- #cells )
  176.   StartArea @ swap 0
  177.   DO
  178.      dup @ Target, cell+
  179.   LOOP
  180.   drop
  181. ;
  182.  
  183.  
  184. : RegisterDiff  ( #bytes -- )  currentdiff +!
  185. \    TargetHere 2+  TargetBase @ -  DiffSizes  +stack
  186.        ThisOp @ 2+     CFABase @ -  DiffSizes  +stack
  187.      currentdiff @  DiffSizes  +stack
  188. ;
  189.  
  190.  
  191. USE_NEW_COLON on
  192.  
  193. : SizeDiff?  ( opadr #bytes -- )
  194.   0 >r   swap w@ swap  ( opcode #bytes )  over BranchOp?
  195.   IF
  196.      ( -- opc #bytes )  over  ShortBRA? 0= 0=  IfLongBranch @ and
  197.      IF
  198.         rdrop 2 >r
  199.      THEN
  200.   ELSE
  201.      ( apcode #bytes )  dup     4  3 pick  $ 4eb9 =
  202.      IF
  203.         2+
  204.      THEN
  205.      ( -- opcode #bytes #bytes #indict )
  206.      rdrop   - >r
  207. \
  208. [ 0 .if ]
  209.      over $ 4eb9 =    over 4 =  and
  210.      IF
  211.         \
  212.         \ original call was Absolute (6 bytes), targeted will be 4...
  213.         \
  214.         rdrop -2 >r
  215.      ELSE
  216.         over $ 4eb9 = 0=  over 6 =  and
  217.         IF
  218.            \
  219.            \ original was relative (4 bytes), targeted will be 6...
  220.            \
  221.            rdrop 2 >r
  222.         THEN
  223.      THEN
  224. [ .then ]
  225. \
  226.   THEN
  227.   r> ?dup
  228.   IF
  229.      ( -- opc #bytes amt-diff )  RegisterDiff
  230.   THEN
  231.   2drop
  232. ;
  233.  
  234. : Special?  ( cfa -- ??_ID , return ID code if not a colon def )
  235.   \
  236.   \ Check if the SFA has a special_ID marked in the SFA...
  237.   \
  238.   dup PacketFor ..@ ref_IsPFA dup
  239.   IF
  240.       drop dup cell- @ $ f,0000 and
  241.   THEN
  242.   swap drop
  243. ;
  244.  
  245. : LITERALADDR?  ( cfa -- flag , true if literal references to a data area )
  246.   Special? dup VARIABLE_ID = swap USER_ID = or
  247. ;
  248.  
  249. : CloneOverlayReference  ( w@aN-2 .. w@a0 N*2 -- )
  250.   0 DO
  251.      TargetW,  2
  252.   +LOOP
  253. ;
  254.  
  255. : WriteOverlayReference  ( w@aN-2 .. w@a0 N*2 tgtaddr -- )
  256. \ x ) dbgon >newline ." Entering WriteOverlayReference: " .s >newline dbgoff
  257.   TargetHERE >r   \ save current tgt-here
  258.   TargetImageBase freebytea !   \ install tgtaddr
  259.   CloneOverlayReference
  260.   r> TargetImageBase freebytea !
  261. ;
  262.  
  263. : CloneExisting  ( opadr tgtcalled calledcfa -- opadr )
  264.   2 pick >r
  265.   LiteralAddr?
  266.   IF
  267.      InMaster @   CloneOverlay @ 0=   or
  268.      IF
  269.         $ 2d07 targetw, \ put in move.l tos,-(dsp)
  270.         2 RegisterDiff
  271.         $ 2e3c          \ opcode for move.l  # ...
  272.         swap   6        ( -- opadr opcode data #bytes )
  273.      ELSE
  274.          \ move.l  d7,(-a6)
  275.          \ move.l  #value,tos
  276.          \ add.l   a5,tos
  277.          \ sub.l   org,tos
  278.          \
  279.          >r
  280.          $ 9e8c
  281.          $ de8d
  282.          r@
  283.          r> 16 -shift
  284.          $ 2e3c
  285.          $ 2d07
  286.          12
  287.      THEN
  288.   ELSE
  289.      TargetHERE      ( -- opadr tgtcalled tgtcalling )
  290.      CalcCall        ( -- opadr opcode data #bytes )
  291.   THEN
  292.   r> over            ( -- opadr opcode data #bytes opadr #bytes )
  293.   SizeDiff?          ( -- opadr opcode data #bytes )
  294. \
  295.   dup 7 <
  296.   IF
  297.      rot TargetW,       ( -- opadr data #bytes )
  298.      4 =
  299.      IF
  300.         TargetW,
  301.      ELSE
  302.         Target,
  303.      THEN
  304.   ELSE
  305.      CloneOverlayReference
  306.   THEN
  307. ;
  308.  
  309.  
  310. : CloneUnresolved  ( opadr calleda -- opadr )
  311.   \
  312.   \ 1. Store called native PFA in opcode 'hole'
  313.   \ 2. Push Target Address of 'hole' on the 'UnResolved' stack.
  314.   \
  315.   dup LiteralAddr?  dup>r
  316.   IF
  317.      $ 2d07 targetw,   2  RegisterDiff
  318.   THEN
  319.   TargetHERE  UnResolved   +stack
  320.   ( -- opadr calleda )  Target,
  321.   ( -- opadr )  CloneOverlay @
  322.   IF
  323.      r@   \ LITERAL?
  324.      IF
  325.         $ 4e71 TargetW,
  326.         dup 6 SizeDiff?  \ 00004
  327.      ELSE
  328. \ x ) dbgon >newline ." CLONEing unresolved at " TargetHERE .hex cr dbgoff
  329.         [ OVERLAY_CALL_SIZE cell- ] literal  TargetAllot
  330.         dup OVERLAY_CALL_SIZE SizeDiff?
  331.      THEN
  332.   ELSE
  333.      IfLeaveLong @  r@ or
  334.      IF
  335.         $ 4e71 TargetW,
  336.         dup 6 SizeDiff?  \ 00004
  337.      ELSE
  338.         \ calc change in size for 4 byte BSR or JSR
  339.         ( -- opadr )  dup 4 SizeDiff? \ 00004
  340.    \ x ) dbgon >newline ." CloneUnresolved, after SizeDiff 4: " .s >newline dbgoff
  341.      THEN
  342.    THEN
  343.    rdrop
  344. ;
  345.  
  346.  
  347. : ResolveCells
  348.   OpenCellsBase freecell  ( -- #unreslvds )  0
  349.   DO
  350.      \
  351.      \ Get the address containing the native PFA...
  352.      \
  353.      OpenCellsBase i cells + @
  354.      \
  355.      \ Get the NATIVE pfa we need to locate in the target...
  356.      \
  357.      dup Target@  ( -- tgtadr nativepfa )
  358.      \
  359.      \ Find its TargetAdr
  360.      \
  361.      abs PacketFor  dup  ..@ ref_Resolved 0=
  362.      IF
  363.         ( -- tgtadr pkt )
  364.         >newline ." UnResolved reference to RESIDENT address " over target@
  365.         base @ >r hex 0 .r ." , from cell " over . r> base !  cr
  366.      ELSE
  367.         ( -- tgtadr pkt )
  368.         dup ..@ ref_TgtAdr  2 pick Target!
  369.      THEN
  370.      2drop
  371.   LOOP
  372.   OpenCellsBase FreeByteA off
  373. ;
  374.  
  375.  
  376. : ResolveODE  ( -- )
  377.   :ClassCFASBase freecell 0
  378.   DO
  379.      i :ClassCFASBase stack@
  380.      ( -- :classCFA ) dup PacketFor ..@ ref_TGTAdr >r
  381.      >LastIvar @  ?dup
  382.      IF
  383.         dup do-does-size -   ( -- ivardata ivarcfa )
  384.         PacketFor ..@ ref_TgtAdr do-does-size + r@ >LastIvar  Target!
  385.         ( -- ivardata )
  386.         BEGIN
  387.            do-does-size -  ( ivcfa )
  388.            dup PacketFor ..@ ref_TgtAdr >r  ( -r- tgtivcfa )  
  389.            dup >IvarClass @ do-does-size - PacketFor
  390.            ..@ ref_TgtAdr do-does-size +  ( ivcfa tgtivclass )
  391.            r@ >IvarClass Target!          ( ivcfa )
  392.            >PrevIvar @ ?dup
  393.         WHILE
  394.            dup  do-does-size - PacketFor
  395.            ..@ ref_TgtAdr do-does-size +  ( previvar tgtPrevIvar )
  396.            r> >PrevIvar Target!           ( previvar )
  397.         REPEAT
  398.         rdrop
  399.      THEN
  400.      rdrop
  401.   LOOP
  402. ;
  403.  
  404. : ResolvePCRels ( -- )
  405.   DictPCRelsBase freecell 0
  406.   DO
  407.      ( -- )
  408.      i DictPCRelsBase stack@  ( -- &dictop )
  409.      PCRel>Dest  ( -- ref-dict-adr )
  410. \ >newline hex .s
  411.      Dict>TGT  ( -- ref-tgt-adr )
  412.      i ImagePCRelsBase stack@  ( -- rta &tgtopcode )  dup>r
  413.      Dest>PCRel dup $ ffff,8000 <  over $ 7fff > or
  414.      IF
  415.         >newline ." Destination PC-relative address too far away: "
  416.         i DictPCRelsBase stack@ .hex  drop
  417.      ELSE
  418.         r@ 2+ TargetW!
  419.      THEN
  420.      rdrop
  421.   LOOP
  422. ;
  423.  
  424. : NoForwardRefs  ( -- , aborts )   \ NEEDS TO HANDLE FORWARD REFS IN OVRLYS
  425.    >newline
  426.    cr ." This version of CLONE cannot resolve forward references"
  427.    cr ." when creating overlays.  This can be caused by DEFERed"
  428.    cr ." words pointing to later definitions.  It is suggested that"
  429.    cr ." you set these to NOOP at compile time, and run-time initialize"
  430.    cr ." the DEFERed words to the later definitions." cr
  431.    cr ." CLONE aborted (INITCLONE before CLONEing again)"  quit
  432. ;
  433.  
  434. : ResolveAll  ( -- )
  435.   ResolveCells
  436.   UnResolvedBase freecell  ( -- #unreslvds )  0
  437.   DO
  438.      \
  439.      \ Get the address containing the native PFA...
  440.      \
  441.      UnResolvedBase i cells + @
  442.      \
  443.      \ Get the NATIVE pfa we need to locate in the target...
  444.      \
  445.      dup Target@  ( -- tgtopadr nativepfa )  dup>r  ( -r- nativecfa )
  446.      \
  447.      \ Find its TargetAdr
  448.      \
  449.      abs PacketFor  dup>r  ..@ ref_Resolved 0=  ( -r- ntvcfa pkt )
  450.      IF
  451.         ( -- tgtopadr )  ( -r- nativepfa??neg pkt )
  452.         >newline ." UnResolved reference to RESIDENT address " dup target@
  453.         base @ swap hex 0 .r ." , from " over . base !  cr
  454.      ELSE
  455.         ( -- tgtopadr )  ( -r- cfa packet )
  456.         r@ ..@ ref_TgtAdr   1 rpick 0<
  457.         IF
  458.            true  ( address literals are saved NEGATEd )
  459.         ELSE
  460.            1 rpick LiteralAddr?
  461.         THEN
  462.         ( -- tgtopadr tgtadr flag )
  463.         IF
  464.            $ 2e3c 2 pick targetW!
  465.            over 2+  Target!
  466.         ELSE
  467.            over
  468.            ( -- calling calledtgtadr callingadr )  dup>r CalcCall
  469.            dup 7 <   CloneOverlay @ 0= or
  470.            IF
  471.               ( -- calling opcode data #bytes )   6 =
  472.               IF
  473.                  IfLeaveLong @ 0=
  474.                  IF
  475.                     2drop >newline
  476.                     ." LONG RELOCATIONS are necessary; the variable IFLEAVELONG" cr
  477.       ( 00001 )     ."      must be set TRUE; then INITCLONE and try again." cr
  478.                     quit
  479.                  ELSE
  480.                     ( -- calling opcode called )    swap 2 pick TargetW!
  481.                     \ already stacked!  ( -- calling called )
  482.                     \ removed!          over 2+ dup TargetABS +stack
  483.                     ( -- calling called )      over 2+  \ 00002
  484.                     ( -- calling called calling+2 )    Target!
  485.                  THEN
  486.               ELSE
  487.                  ( -- opadr opcode displacement )  swap 2 pick TargetW!
  488.                  over 2+ TargetW!  ( -- opadr )
  489.               THEN
  490.            ELSE
  491.                ( -- calling wdata@adrN-2 .. wdata@adr0 N*2 )
  492.                ( -r- ntvcfa pkt callingop )
  493. [ 1 .if ]
  494. ( x ) dbgon >newline ." write fwd ref: " cr r@ base @ >r hex .s r> base ! drop cr dbgoff
  495.               r@  WriteOverlayReference
  496. [ .else ]
  497.               NoForwardRefs
  498. [ .then ]
  499.            THEN
  500.            rdrop
  501.         THEN
  502.      THEN
  503.      drop  2 xrdrop
  504.   LOOP
  505.   UnResolvedBase FreeByteA off
  506.   ResolveODE
  507.   ResolvePCRels
  508. ;
  509.  
  510.  
  511. : CloneCall  ( opadr calledadr -- opadr )
  512.   \
  513.   \ This address calls 'nother...   ( -- opadr calledadr )
  514.   \
  515.   dup PacketFor dup ..@ ref_Resolved
  516.   ( -- opadr calledadr calledpkt  flag )
  517.   IF
  518.      \
  519.      \ the word exists in the target...
  520.      \
  521.      ..@ ref_tgtadr  ( -- opadr calleda tgta )
  522.      swap            ( -- opadr tgtcalled calledcfa )
  523.      CloneExisting
  524.   ELSE
  525.      \
  526.      \ the word has NOT been built in the Target yet.
  527.      \
  528.      ( -- opadr calleda calledpkt )
  529. \ x ) dbgon >newline ." CloneCall, not resolved: " .s >newline dbgoff
  530.      drop CloneUnresolved
  531.   THEN
  532.   \
  533.   \ Is this call followed by a string?
  534.   \
  535.   ( -- opadr )  dup +NextOp drop $op @
  536.   IF
  537.      >r
  538.      r@ dup w@ opsize dup >r +   ( -- $startaddr )  ( -r- opadr oplen )
  539.      r> r@ +NextOp swap -        ( -- $start $len )
  540.      2/ 0
  541.      DO
  542.         dup w@  ( dup hex . ) TargetW,  2+
  543.      LOOP
  544.      drop r>
  545.   THEN
  546. ;
  547.  
  548. : CheckOverlayRelative  ( -- )
  549.   CloneOverlay @  InMaster @ 0=  and
  550.   IF
  551.      \ make relative
  552.      $ de8d Targetw,        \ add.l  a5,tos
  553.      $ 9e8c Targetw,        \ sub.l  org,tos
  554.      4 RegisterDiff
  555.   THEN
  556. ;
  557.  
  558. : CloneALit  ( opadr referenced-adr -- opadr )  Substitute?
  559.   dup do-does-size - IsValuePFA?  ( CloneOverlay @ 0= and )
  560.   IF
  561.      $ 2e3c Targetw,  TargetHERE  ValueRefs +stack   Target,
  562.      CheckOverlayRelative
  563.      ( targetdataAddr = dictdataaddr  ValueRefsStack = TargetDataAddr )
  564.   ELSE
  565.      dup ValidPFA?
  566.      IF
  567.         \
  568.         \ the address IS a cfa
  569.         \
  570.         dup PacketFor dup ..@ ref_Resolved   ( -- opadr ref-adr packet flag )
  571.         IF
  572.            $ 2e3c TargetW,
  573.            ..@ ref_TgtAdr  Target,   CheckOverlayRelative
  574.            drop
  575.         ELSE
  576. [ 0 .if
  577.            \
  578.            \ not built in target yet...
  579.            \
  580.            CloneOverlay @
  581.            IF
  582.               NoForwardRefs  \ aborts
  583.            THEN
  584. [ .then ]
  585.            drop
  586.            TargetHERE UnResolved +stack              \ save tHERE as unrslvd
  587.            negate  ( negative=flag for ALit) Target, \ install dict adr in img
  588.            $ 4e71 Targetw,
  589.         THEN
  590.      ELSE
  591.         \
  592.         \ assume it's referencing some CREATE DOES> child...
  593.         \
  594.         ( -- opadr refadr )           dup >CFA
  595.         ( -- opadr refadr it's-cfa )  dup cell- @  $ f,0000 and
  596.         CASE
  597.            VARIABLE_ID of
  598.               dup [ PktBase ' PktBase - ] literal +
  599.               ( -- opadr refadr cfa cfa+data ) 2 pick
  600.               swap ( 00001 )      -  endof
  601.            CREATE_ID   of
  602.               2dup -           endof
  603. \          VALUE_ID   of
  604.            >newline ." ALITERAL points to ????, can't CLONE opcode at "
  605.            ThisOp @ hex u. quit
  606.         ENDCASE
  607.         ( -- opadr refadr cfa diff-from-tgt-adr ) swap
  608.         PacketFor    ( -- opadr refadr diff pkt )  ..@ ref_TgtAdr +
  609.         $ 2e3c TargetW,  Target,   CheckOverlayRelative  drop
  610.      THEN
  611.   THEN
  612. ;
  613.  
  614. 0 .IF
  615. : CloneBranch  ( opadr destadr -- opadr )
  616.   dup hibranch @ max hibranch !
  617.   over w@ ( -- opadr destadr opcode )
  618.   dup ShortBRA?
  619.   IF
  620.      2 pick 4 SizeDiff?
  621.   THEN
  622.   targetHERE  BranchAdrs   +stack
  623.   dup $ 5fff >
  624.   IF
  625.      $ ff00 and
  626.   THEN Targetw,
  627.   \
  628.   \ after the opcode, save the dict-cfa-relative address referenced...
  629.   \
  630.   CFABase @ -  Targetw,
  631. ;
  632.  
  633.  
  634. : FixBranch  ( TGTopadr -- )
  635.   \
  636.   \ get the dict-rel-addr being called...
  637.   \
  638.   2+ dup Targetw@  ( -- tgtdispadr reldest )
  639.   DiffSizesBase     ( -- tgtdispadr reldest base )
  640.   dup freebyte +
  641.   BEGIN
  642.      [ 2 cells ] literal -  dup @  2 pick <=
  643.   UNTIL
  644.   cell+ @  ( -- disptgtadr reldest sizediff )  + targetbase @ +
  645.   over - swap targetw!
  646. ;
  647. .ELSE
  648. : CloneBranch  ( opadr destadr -- opadr )
  649.   2 x>r
  650.   \           1      0
  651.   \  ( -r- destadr opadr )
  652.   \
  653.   1 rpick  hibranch @ ( hex .s ?pause decimal )  max hibranch !
  654.   r@ w@ dup >r   ShortBRA? >r
  655.   \
  656.   \           3      2      1      0
  657.   \  ( -r- destadr opadr opcode ifshort )
  658.   \
  659.   IfLongBranch @
  660.   IF
  661.      r@
  662.      IF
  663.         2 rpick 4 SizeDiff?
  664.      THEN
  665.   THEN
  666.   \
  667.   targetHERE  BranchAdrs   +stack
  668.   1 rpick dup  $ 5fff >  IfLongBranch @ and
  669.   IF
  670.      $ ff00 and
  671.   THEN
  672.   Targetw,
  673.   \
  674.   \ after the opcode, save the dict-cfa-relative address referenced...
  675.   \
  676.   3 rpick  CFABase @ -  FromCFAs  +stack
  677.   r@  IfLongBranch @ 0=  and  0=
  678.   IF
  679.      0 Targetw,
  680.   THEN
  681.   2 xrdrop r> rdrop
  682.  
  683. ;
  684.  
  685. : FixBranch  ( TGTopadr branch# -- )
  686.   2 x>r
  687.   \           1        0
  688.   \  ( -r- branch# TGTopadr )  
  689.   \
  690.   \ get the dict-rel-addr being called...
  691.   \
  692.   1 rpick FromCFAsBase stack@  ( -- reldest )
  693.   DiffSizesBase     ( -- reldest base )
  694.   dup freebyte +
  695.   BEGIN
  696.      [ 2 cells ] literal -  dup @  2 pick <=
  697.   UNTIL
  698.   cell+ @  ( -- reldest sizediff )  + targetbase @ +
  699.   ( -- tgtaddr )  r@ 2+ -  >r
  700.   \
  701.   \           2        1          0
  702.   \  ( -r- branch# TGTopadr displacement)  
  703.   \
  704.   1 rpick Targetw@ ShortBRA?
  705.   IF
  706.      r@ 127 >   r@ -128 <  OR
  707.      IF
  708. \ x ) dbgon >newline r@ dup . .hex 1 rpick dup . .hex 2 rpick dup . .hex cr dbgoff
  709.         >newline
  710.         ." Too far for SHORT BRANCH...aborting CLONE operation." cr
  711.         ." To successfully CLONE this program..." cr
  712.         ." 1. Enter:   INITCLONE  IFLONGBRANCH ON  <return>" cr
  713.         ." 2. Restart CLONE as before" quit
  714.      ELSE
  715.         1 rpick targetw@  $ ff00 and
  716.         r@ $ 0ff and  or  1 rpick targetw!
  717.      THEN
  718.   ELSE
  719.      r@  1 rpick 2+  targetw!
  720.   THEN
  721.   3 xrdrop
  722. ;
  723.  
  724. .THEN
  725.  
  726. : Set?DO   ( dict-ix-addr -- )  dup @  over 8 + +  ( -- ixadr dict-dest )
  727.   CFABase @ -   ( -- ixadr dict-cfarel-dest )
  728.   targetHERE cell-  dup ?DOIndexes +stack    Target!  drop
  729. ;
  730.  
  731. : Fix?DO  ( ixTGTadr -- )  dup Target@  ( -- ixadr dict-rel-addr )
  732.   DiffSizesBase     ( -- tgtixadr reldest base )
  733.   dup freebyte +
  734.   BEGIN
  735.      [ 2 cells ] literal -  dup @  2 pick <=
  736.   UNTIL
  737.   cell+ @  ( -- tgtixadr reldest sizediff )  + targetbase @ +
  738.   over 8 + - swap target!
  739. ;
  740.  
  741.  
  742. : FixValues  ( -- , references registered on ValueRefs stack )
  743.   ValueRefsBase dup freecell 0
  744.   DO
  745.      i over stack@    ( -- base &tgtlit )
  746.      dup Target@      ( -- base &tgtlit &dictdata )
  747.      dup do-does-size - PacketFor dup ..@ ref_resolved 0=
  748.      IF
  749.         ( -- base &tgtlit &dictdata pkt )
  750.         TargetHERE over ..! ref_TgtAdr
  751.         true over ..! ref_resolved
  752.         over @ Target,
  753.      THEN
  754.      ( -- base &tgtlit &dictdata pkt )  swap drop
  755.      ..@ ref_TgtAdr swap Target!  ( -- base )
  756.   LOOP freebytea off
  757. ;
  758.  
  759.  
  760. : IfCall   ( opadr flag -- opadr flag' )
  761.   dup 0=
  762.   IF
  763.       drop dup calls?  dup
  764.       IF
  765. \ x ) dbgon >newline ." IfCall. calls? returned true: " .s >newline dbgoff
  766.           drop ( opadr calledadr )  dup ' ((?DO)) =
  767.           IF
  768.              ( -- opadr called )  over cell-  Set?DO
  769.           ELSE
  770.              Substitute?
  771.           THEN
  772.           CloneCall true
  773.       THEN
  774.   THEN
  775. ;
  776.  
  777.  
  778. : IfBranch   ( opadr flag -- opadr flag' )
  779.   dup 0=
  780.   IF
  781.       drop dup Branches?  dup
  782.       IF
  783.           drop CloneBranch true
  784.       THEN
  785.   THEN
  786. ;
  787.  
  788.  
  789. : IfALit   ( opadr flag -- opadr flag' )
  790.   dup 0=
  791.   IF
  792.       drop dup ALit?  dup
  793.       IF
  794.           drop CloneALit  true
  795.       THEN
  796.   THEN
  797. ;
  798.  
  799.  
  800. : IfInline   ( opadr flag -- opadr flag' , last check! )
  801.   dup 0=
  802.   IF
  803.      drop
  804.      dup dup w@ dup $ 4e71 =
  805.      IF
  806.         2drop true      \ do not include 'nop's
  807.         -2 RegisterDiff
  808.      ELSE
  809.         opsize  dup TargetAllot  ( -- opadr opadr size )
  810.         TargetHere over -  TargetImageBase + swap move
  811.         \
  812.         \ Last instruction?
  813.         \
  814.         dup w@ $ 4e75 =  over hibranch @ >=   and 0=
  815.      THEN
  816.   THEN
  817.   ( -- opadr flag , flag=false if end of this pfa )
  818. ;
  819.  
  820.  
  821. : IfLibOpen?  ( opadr flag -- opadr' flag' )
  822.   dup 0=
  823.   IF
  824.      >r ( -- opadr )   dup CallingLibOpen?
  825.      IF
  826.         16 +   -20 RegisterDiff    16 ThisOp +!
  827.         rdrop  true >r
  828.      THEN
  829.      r>
  830.   THEN
  831. ;
  832.  
  833. : IfPCRel  ( opadr flag -- opadr' flag' )
  834.   dup 0=
  835.   IF
  836.      drop  dup w@ dup PCRel?  ( -- opadr opcode flag )
  837.      over 1 and 0= and   \ can't calc xx(pc,??)
  838. \ >newline .s ?pause
  839.      IF
  840.         over DictPCRels +stack
  841.         TargetHERE ImagePCRels +stack
  842.         TargetW,   0 TargetW,
  843.         true
  844.      ELSE
  845.         drop false
  846.      THEN
  847.   THEN
  848. ;
  849.  
  850. : CloneOpcode   ( opadr -- opadr flag , true=more to do )
  851.   dup thisOp !  false
  852.   IfCall        ( -- opadr flag , true if processed )
  853.   IfBranch      ( -- opadr flag )
  854.   IfALit        ( -- opadr flag )
  855.   IfLibOpen?    ( -- opadr flag )
  856.   IfPCRel       ( -- opadr flag )
  857.   IfInLine      ( -- opadr flag )
  858. ;
  859.  
  860. .need CFATABLE>
  861. defer CFATABLE>
  862. .then
  863.  
  864. : CloneIV  ( objbase class-cfa -- )
  865.   dup >LastIvar @   ( -- objbase classCFA lastivar )
  866.   BEGIN
  867.      ?dup
  868.   WHILE
  869.      ( objbase classCFA lastivar )              dup @ 3 pick +
  870.      ( objbase classCFA lastivar nextobjbase )  over do-does-size -
  871.      ( objbase classCFA lastivar nextobjbase instobjcfa )
  872.      >IvarClass @ do-does-size -   recurse
  873.      do-does-size - >PrevIvar @
  874.   REPEAT
  875.   ( objbase class-cfa -- )
  876.   >CFATable
  877.   dup CFATables stackfind   ( -- objbase &table ix flag )
  878.   IF
  879.      cells TGTCFATables     @ ( fix by Phil )   + @ >r
  880.   ELSE
  881.      2dup CFATables stackinsert   ( -- objbase &table ix )
  882.      TargetHERE dup >r
  883.      swap TGTCFATables stackinsert  ( -- objbase &table )
  884.      dup >#methods 0
  885.      DO
  886.         dup @ Substitute?
  887.         PacketFor ..@ Ref_TgtAdr Target,  cell+
  888.      LOOP
  889.   THEN
  890.   drop  ( -- objbase )  CFABase @ -  TargetBase @ +  r> swap Target!
  891. ;
  892.  
  893. : CloneHighLevel  ( -- )
  894.   CFABase @      ( -- pfa )
  895.   BEGIN
  896.      \
  897.      \ piece up the code, opcode at a time...
  898.      \
  899. \ x ) dbgon >newline ." New Opcode =============================" cr .s
  900. \ x )     ?pause >newline dup .hex space dbgoff
  901.      ( -- opadr )  CloneOpcode  ( -- opadr flag )
  902.   WHILE
  903.      dup +NextOp
  904. \ x ) dbgon dup ."  next Opcode is + " .hex cr dbgoff
  905.      +
  906.   REPEAT
  907.   drop
  908. \ x ) dbgon >newline ." Fixing branches" cr .s cr dbgoff
  909.   BranchAdrsBase dup freecell 0
  910.   DO
  911.      dup @ i FixBranch cell+
  912.   LOOP
  913.   drop  BranchAdrsBase Freebytea off   FromCFAsBase Freebytea off
  914. \ x ) dbgon >newline ." Fixing ?DOs" cr dbgoff
  915.   ?DOIndexesBase dup freecell 0
  916.   DO
  917.      dup @ Fix?DO cell+
  918.   LOOP
  919.   drop  ?DOIndexesBase Freebytea off
  920.   FixValues
  921. [ 0 .if ]
  922.   CFABase @ dup
  923.   Special?  dup CREATE_ID = swap GLOBDEF_ID = or
  924.   swap ' sample-defer = or
  925. [ .else ]
  926.   CFABase @   Special?  dup  CREATE_ID =
  927. [ .then ]
  928.   IF
  929. \ x ) dbgon >newline ." Found to be CREATE_DOES" cr dbgoff
  930.      drop
  931.      \
  932.      \ calc beginning of data area...
  933.      \
  934.      do-does-size  TargetHERE TargetBase @ - - TargetALLOT
  935.      \
  936.      \ calc length of data area...
  937.      \
  938.      TargetHERE TargetDataStart !
  939.      CFABase @   do-does-size +  AllotData
  940.      \
  941.      \ Check if it is a CLASS definition...
  942.      \
  943.      CFABase @ cell- @ CLASS_BIT and
  944.      IF
  945.         \ get the addr of the CFAs table...
  946.         \
  947.         CFABase @ do-does-size + dup @  ( -- objbase CFATable )
  948.         CFATable>  CloneIV     ( -- )
  949.      ELSE
  950.         \ Check if it is a :CLASS definition...
  951.         \
  952.         CFABase @ cell- @ :CLASS_BIT and
  953.         IF
  954.            \ get the addr of the CFAs table...
  955.            \
  956.            CFABase @ dup dup :ClassCFAS StackLocate :ClassCFAS StackInsert
  957.            >CFATable  dup CFATables stackfind  ( -- tbl ix flag )
  958.            drop   2dup CFATables stackinsert   ( -- &table ix )
  959.            TargetBase @ >CFATable  dup >r
  960.            swap TGTCFATables stackinsert  ( -- &table )
  961.            dup >#methods   r> swap 0
  962.            DO
  963.               ( -- &table &TGTtable )  over @ substitute?
  964.               ( -- &table &TGTtable rescalledadr )
  965.               dup PacketFor dup ..@ ref_Resolved
  966.               IF
  967.                  ( tbl tgttbl called pkt )
  968.                  ..@ Ref_TgtAdr  swap drop  over Target!
  969.               ELSE
  970.                  drop
  971.                  over dup OpenCells +stack   Target!
  972.               THEN
  973.               cell+ swap cell+ swap
  974.            LOOP
  975.            2drop
  976.         THEN
  977.      THEN
  978.   ELSE
  979.      \ is it adefered word?
  980.      GLOBDEF_ID =
  981.      IF
  982. \ x ) dbgon >newline ." Found to be a DEFERed word" cr dbgoff
  983.         TargetHERE TargetDataStart !
  984.         \
  985.         \ CFABase @   defer-size +  AllotData
  986.         cell TargetAllot
  987.         \
  988.         \
  989.         CloneOverlay @
  990.         IF
  991.            $ d800  TargetDataStart @ cell- TargetW!
  992.         THEN
  993.      THEN
  994.   THEN
  995. ;
  996.  
  997.  
  998. : CloneVARIABLE  ( -- )
  999.   TargetHERE TargetDataStart !
  1000.   CFABase @  [ clicommand  ' clicommand - ] literal +  AllotData
  1001. ;
  1002.  
  1003.  
  1004. : CloneUSER  ( -- )
  1005.   TargetHERE TargetDataStart !
  1006.   CFABase @execute @ Target,
  1007. ;
  1008.  
  1009.  
  1010. : SetDefered  ( -- )
  1011.   CFABase @  >is @
  1012.   Substitute?  ( -- calledadr )
  1013.   dup PacketFor dup ..@ ref_Resolved  ( -- called pkt flag )
  1014.   IF
  1015.      ..@ Ref_TgtAdr  TargetDataStart @  Target!  drop
  1016.   ELSE
  1017. [ 0 .if ]
  1018.      CloneOverlay @
  1019.      IF
  1020.         NoForwardRefs
  1021.      THEN
  1022. [ .then ]
  1023.      drop
  1024.      TargetDataStart @ dup OpenCells +stack   Target!
  1025.   THEN
  1026. ;
  1027.  
  1028.  
  1029. : CloneGLOBDEF  ( -- )
  1030.   CloneHighLevel  SetDefered
  1031. ;
  1032.  
  1033. 0 .IF
  1034. : CloneUSERDEF  ( -- )  CFABase @ >r
  1035.   ' SAMPLE-DEFER CFABase !
  1036.   IfCreateRefs on
  1037.   CloneHighLevel
  1038.   r>  CFABase !    SetDefered
  1039.   IfCreateRefs off
  1040.   ' SAMPLE-DEFER  References  StackFind
  1041.   IF
  1042.      dup cells RefPacketsBase + @ freeblock
  1043.      dup References StackRemove
  1044.      dup RefPackets StackRemove
  1045.   THEN
  1046.   drop
  1047. ;
  1048. .ELSE
  1049. : CloneUSERDEF  ( -- )  CloneGLOBDEF  ;
  1050. .THEN
  1051.  
  1052. : CloneSpecial  ( ??_ID -- )
  1053.   CASE
  1054.      VARIABLE_ID of CloneVARIABLE       endof
  1055.      USER_ID     of CloneUSER           endof
  1056.      CREATE_ID   of CloneHighLevel      endof
  1057.      USERDEF_ID  of CloneUSERDEF        endof
  1058.      GLOBDEF_ID  of CloneGLOBDEF        endof
  1059. \    VALUE_ID    of CloneHighLevel      endof
  1060.        >newline ." Undefined 'DATA'_ID:" dup .hex
  1061.        ."   Cloning:"  CFABase @ .hex
  1062.   ENDCASE
  1063. ;
  1064.  
  1065.  
  1066. : CloneReference  ( cfa -- )
  1067.   dup IsValuePFA? 0=
  1068.   IF
  1069.      \
  1070.      \ Initializations...
  1071.      \
  1072.      dup PacketFor PktBase !   CFABase ! 
  1073.      DiffSizesBase FreeByteA off \ init the sizediffs stacks...
  1074.      0  DiffSizes  +stack
  1075.      0  DiffSizes  +stack
  1076.      CurrentDiff off             \ no difference at start...
  1077.      TargetHERE TargetBase !     \ save the start tgt adr...
  1078.      HiBranch off                \ no branches yet!
  1079.      \
  1080.      \ not a normal colon def?
  1081.      \
  1082.      CFABase @ Special? -dup
  1083.      IF
  1084.         CloneSpecial
  1085.      ELSE
  1086.         CloneHighLevel
  1087.      THEN
  1088.      PktBase @ >r
  1089.      TargetBase @  r@  ..! ref_TgtAdr
  1090.      true          r>  ..! ref_Resolved
  1091.   ELSE
  1092.      drop
  1093.   THEN
  1094. ;
  1095.  
  1096. : CLONE.SETUP.TARGET  ( size -- , preallocate target to save RAM )
  1097.     InitialSize @
  1098.     swap InitialSize !
  1099.     TargetImage  ( allocate data )
  1100.     0= abort" Couldn't Allocate InitialImageSize Target Area!"
  1101.     InitialSize !
  1102. ;
  1103.  
  1104. : (FreeOverlay)  ( cfa -- , depends on CLONE putting variable right before )
  1105. \ >newline cr ." checking overlay variable..." cr
  1106.   cell- dup @ ?dup
  1107.   IF
  1108. \ >newline cr ." freeing overlay" cr
  1109.      cell-  FreeBlock   dup off
  1110.   THEN
  1111.   drop
  1112. ;
  1113.  
  1114. : CLONECFA  ( cfa -- )
  1115. \ x ) dbgon >newline ." Entering CLONECFA..." cr .s >newline dbgoff
  1116.   InitialImageSize @ ?dup
  1117.   IF  clone.setup.target
  1118.   THEN
  1119.   \
  1120.   CFABase off
  1121.   ' noop dup is UserCleanUp   is ErrorCleanup
  1122.   \
  1123.   \ Make sure 'StartJForth' is first code word assembled...
  1124.   \
  1125.   CloneOverlay @
  1126.   IF
  1127.      ' StartOverlay
  1128.   ELSE
  1129.      ' StartJForth
  1130.   THEN
  1131.   dup>r  references StackFind swap drop 0=
  1132.   IF
  1133. \ x ) dbgon >newline ." Before tracing start word..." cr .s >newline dbgoff
  1134.      r@ TracePFA
  1135. \     CloneOverlay @
  1136. \     IF
  1137. \        0 Target,
  1138. \     THEN
  1139. \ x ) dbgon >newline ." Before building start word..." cr .s >newline dbgoff
  1140.      r@ CloneReference
  1141. \ x ) dbgon >newline ." Before CLONEing start word..." cr .s >newline dbgoff
  1142.      r@ myself
  1143. \ x ) dbgon >newline ." After CLONEing start word..." cr .s >newline dbgoff
  1144.      r@ PacketFor   1 swap ..! ref_#Times
  1145.   THEN
  1146.   rdrop
  1147.   \
  1148.   \ ( -- cfa )  Check if this word must be redefined...
  1149.   \
  1150.   Substitute?
  1151.   \
  1152.   \ ( -- cfa )  get all called definitions...
  1153.   \
  1154. \ x ) dbgon >newline ." Before tracing main word..." cr .s cr cr cr dbgoff
  1155.   TracePFA    ( -- )
  1156. \ x ) dbgon >newline ." After tracing main word..." cr .s cr dbgoff
  1157.   \
  1158.   \ Replace @execute for DEFER-EXECUTE...
  1159.   \
  1160. [ 0 .if ]
  1161.   ' defer-execute references StackFind  ( -- index flag )  swap drop
  1162.   IF
  1163.      ' sample-defer  TracePFA
  1164.      ' defer-execute references StackFind  ( -- index flag )  drop
  1165.      dup cells RefPacketsBase + @    ( -- defix pkt )
  1166.      over  References  StackRemove
  1167.      swap  RefPackets  StackRemove   ( -- pkt )
  1168.      dup ..@ ref_#Times swap freeblock
  1169.      ' @execute PacketFor dup ..@ ref_#Times   ( -- #times1 pkt #times2 )
  1170.      rot + swap ..! ref_#Times
  1171.   THEN
  1172.   ' SAMPLE-DEFER  References  StackFind
  1173.   IF
  1174.      dup cells RefPacketsBase + @ freeblock
  1175.      dup References StackRemove
  1176.      dup RefPackets StackRemove
  1177.   THEN
  1178.   drop
  1179. [ .THEN ]
  1180.   IfCreateRefs off   
  1181.   \
  1182.   \ Build from lowest cfa to highest...
  1183.   \
  1184.   References @ freebyte  ( -- #references*4 )  0
  1185.   DO
  1186.      RefPackets @ i + @  ( -- addr-of-pkt )
  1187.      ..@ ref_resolved 0=
  1188.      IF
  1189. \ x ) dbgon ." status..." cr cr cr dbgoff
  1190.         Status?
  1191.         References @ i + @
  1192.         \
  1193.         \ ( -- cfa )  this word needs built in the target.
  1194.         \
  1195.         CloneReference
  1196.      THEN
  1197.      cell
  1198.   +LOOP
  1199.   \
  1200.   \ Now take care of the kernal words that forward referenced...
  1201.   \
  1202.   ResolveAll
  1203. \ x ) dbgon >newline ." Entering CLONECFA..." cr .s >newline dbgoff
  1204. ;
  1205.  
  1206.  
  1207. \ ---------------------- overlay stuff
  1208.  
  1209. getmodule includes
  1210.  
  1211. : GetFileSize  { $name | bytes fib flock -- bytes , 0=error }
  1212.   0 -> bytes
  1213.   $name access_read $lock() ?dup
  1214.   IF
  1215.      -> flock   MEMF_PUBLIC sizeof() FileInfoBlock allocblock ?dup
  1216.      IF
  1217.         -> fib   flock fib Examine()
  1218.         IF
  1219.            fib ..@ fib_Size -> bytes
  1220.         THEN
  1221.         fib freeblock
  1222.      THEN
  1223.      flock Unlock()
  1224.   THEN
  1225.   bytes
  1226. ;
  1227.  
  1228. asm CallOverlay  ( code-start -- )
  1229.     move.l  tos,a0
  1230.     move.l  (dsp)+,tos
  1231.     jsr     0(org,a0.l)
  1232.     forth{ ] both [  }
  1233. end-code
  1234.  
  1235. variable OVERLAYERROR
  1236.  
  1237. : LoadOverlay   { $file | fsize mem file -- addr-mem / 0 }
  1238.   0 -> mem
  1239.   $file GetFileSize dup -> fsize
  1240.   IF
  1241.      $file old $fopen dup -> file
  1242.      IF
  1243.         MEMF_CLEAR fsize allocblock dup -> mem
  1244.         IF
  1245.            file  mem   fsize   fread  fsize -
  1246.            IF
  1247.               >newline ." Error reading Overlay file" cr
  1248.               file fclose  mem freeblock  0 -> mem
  1249.               OverLayError on
  1250.               quit
  1251.            ELSE
  1252.               cell +-> mem
  1253.            THEN
  1254.         ELSE
  1255.            >newline ." No memory for Overlay file" cr quit
  1256.         THEN
  1257.         file fclose
  1258.      ELSE
  1259.         >newline ." Can't open Overlay file" cr quit
  1260.      THEN
  1261.   THEN
  1262.   mem
  1263. ;
  1264.  
  1265. : DoOverlay  { $filename var -- }
  1266.   OverLayError off
  1267.   var @ ?dup 0=
  1268.   IF
  1269.      $filename  LoadOverlay dup
  1270.      IF
  1271.         dup var !
  1272.         \ compile as a CALL...
  1273.         [ max-inline @  6 max-inline ! ]
  1274.         CallOverlay
  1275.         [ max-inline ! ]
  1276.      THEN
  1277.   ELSE
  1278.      \ compile INLINE...
  1279.      [ max-inline @  128 max-inline ! ]
  1280.      CallOverLay
  1281.      [ max-inline ! ]
  1282.   THEN
  1283. ;
  1284.  
  1285.  
  1286. USE_NEW_COLON off
  1287.  
  1288.  
  1289. also Forth Definitions
  1290.  
  1291. : MakeOverlay  { | old>in thevarcfa -- , <wordname> }
  1292.   only redefs definitions
  1293.   >in @ -> old>in
  1294.   bl word find nip 0=   \ not already redefed?
  1295.   IF
  1296.      old>in >in !   definitions
  1297.      " OVR" count here $append   skip-word? on  [compile] variable
  1298.      latest name> -> thevarcfa
  1299.      \
  1300.      [compile] :   old>in >in !
  1301.      COMPILE ($")  bl $,
  1302.      thevarcfa cfa,   compile DoOverLay   [compile] ;
  1303.   THEN
  1304.   only forth definitions
  1305.   OverlaysDefined on
  1306. ;
  1307.  
  1308.  
  1309. : CLONE.FWARNING ( -- , warn if files open )
  1310.     fcloseatbye @ memcells? 0>
  1311.     fblk @ 0= AND
  1312.     IF  >newline ." WARNING - Files Open during Clone!" cr
  1313.         ."   Any files used by a Cloned program must be opened" cr
  1314.         ."   by that program when run." cr
  1315.     THEN
  1316. ;
  1317.  
  1318. : CLONE  ( <name> -- , create royalty free image )
  1319.   >newline
  1320.   clone.fwarning
  1321.   MaxImageSize @
  1322.   IF
  1323.      ." NOTE: the VARIABLE 'MaxImageSize' is no longer used by CLONE."
  1324.      cr
  1325.   THEN
  1326.   [compile] '  cr   dup CloneInputCFA !
  1327.   " 1m" CSIType
  1328.   ."   CLONE (version 1.5 Beta)  by Mike Haas, 06-May-92"
  1329.   " 0m" CSIType  cr  InitStatus
  1330.   OverlaysDefined @
  1331.   IF
  1332.      ' (FreeOverlay)
  1333.   ELSE
  1334.      ' drop
  1335.   THEN
  1336.   is FreeOverlay
  1337.   \
  1338.   CloneCFA   ' drop is FreeOverlay
  1339.   \
  1340.   .status   cr cr   ;
  1341.  
  1342. previous definitions
  1343.  
  1344. : (TrapPacket)   ( cfa refix -- )  base @ >r   hex
  1345.   >newline cr   ." REFERENCE ERROR:  cloning "
  1346.   CFABase @  1 .r   ." , the opcode at "
  1347.   ThisOp  @  1 .r   cr
  1348.   ." is trying to create a reference to "  swap u.
  1349.   cr TargetHERE  ." TargetHERE = " u.
  1350.   r> base !
  1351.   quit
  1352. ;
  1353.  
  1354. ' (TrapPacket) is TrapPacket
  1355.  
  1356. only forth definitions
  1357. also TGT
  1358.